package Zim::Store;

use strict;
use Carp;
use Zim::Page;

our $VERSION = '0.20';

=head1 NAME

Zim::Store - Base class for page storage objects

=head1 DESCRIPTION

This is a base class for storage backends.
It documents the interface expected to handle page objects.
It provides a number of stub methods and some logic that is common to most
stores.

When implementing a new store at least implement C<get_page()>,
C<resolve_name()> or C<resolve_case()>. When implementing a
repository that is writable C<delete_page()> also needs to be there.
You might want to implement a native C<copy_page()> and C<move_page()>
also then.
To make your pages show up in the side pane implement C<list_pages()>.
All other methods are optional.

Note that when a page name is given it is always given fully-specified,
so you need to take into account your own namespace prefix.

It is good practice to throw an exception when a method fails.
This way the GUI knows that something went wrong and can alert the user.

=head1 METHODS

=over 4

=item new(parent => PARENT, namespace => NAMESPACE, ...)

Simple object constructor.
PARENT can be a parent repository object or undef.
NAMESPACE is the prefix for all pages managed by this repository.

=cut

sub new {
	my $class = shift;
	my %param = @_;
	$param{namespace} ||= ':' ;
	$param{namespace} =~ s/:?$/:/;
	$param{indexpage} ||= $param{namespace};
	$param{indexpage} =~ s/:*$//;
	my $self = bless {%param}, $class;
	$self->init();
	return $self;
}

=item C<init()>

Stub init function, to be overloaded.

=cut

sub init { }

=item C<list_pages(NAMESPACE)>

This method should return a list of pages in NAMESPACE.
The list is used by the gui to produce a hierarchical index,
it does not tell anything about the actual existence of the pages.

The default returns an empty list.

=cut

sub list_pages { }

=item C<get_page(NAME)>

This method is expected to return a page object for NAME.
See L<Zim::Page> for an example.

When a page does not exist an empty object should be returned
that can be used to create this page by saving to it.
The status of this object should be set to 'new'.
When a page does not exists and can not be created undef should
be returned.

The default does nothing.

=cut

sub get_page { die 'BUG: not implemented: '.ref($_[0])."->get_page()\n" }

=item C<resolve_page(LINK, PAGE, NO_DEFAULT)>

Convenience function packing C<resolve_name()> and C<get_page()>.

=cut

sub resolve_page {
	my $self = shift;
	my $name = $self->resolve_name(@_);
	return $name ? $self->root->get_page($name) : undef ;
}

=item C<resolve_name(NAME, REF, NO_DEFAULT)>

Resolves a page relative to a given path. Does an upward search through
the path for relative links. This search is depth first (or actually
"surface first"), since checking the given path is cheaper than doing
a in width search.

* make name case sensitive
* match name against REF
* check existence

for matching only use first element of NAME
either anchored in path REF or an existing leaf of REF
match case-insensitive.

when a match is found the remainig parts of NAME
need to be resolved to put them in correct case

without REF, or when NAME starts with ':'
we consider the absolute name a direct match
and continue with resolving case

when no match is found a default is returned
unless NO_DEFAULT is set
this default is the REF minus the last part plus
all parts of NAME in their original case

=item C<resolve_case(\@NAME, \@REF)>

B<Private> method called by C<resolve_name()>.
To be overloaded by child classes.

NAME contains the parts of the pagename we are looking for.
REF contains parts of the pagename we use as base for a relative lookup.
Try to match the first part of NAME in the path defined by REF.
If REF is undefined, just start from ":".

=cut

sub resolve_name { #warn "resolve_name(@_)\n";
	my ($self, $link, $page, $no_def) = @_;
	my @link = grep length($_), split /:+/, $link;
	my @page = $page ? (grep length($_), split /:+/, "$page") : ();
	my $anchor = lc $link[0];
	my $name;
	if ($link =~ /^:/ or ! @page) { # absolute name
		my @copy = @link;
		$name = $self->resolve_case(\@link) || ':'.join ':', @copy;
	}
	elsif (grep {lc($_) eq $anchor} @page) { # anchored in path
		my ($i) = grep {lc($page[$_]) eq $anchor} reverse 0 .. $#page;
		shift @link; # shift anchor
		splice @page, $i+1, $#page, @link;
		my @copy = @page;
		$name = $self->resolve_case(\@page) || ':'.join ':', @copy;
	}
	else { # match in width
		pop @page; # pop basename
		my @copy = (@page, @link);
		$name = $self->resolve_case(\@link, \@page);
		$name ||= ':'.join(':', @copy) unless $no_def;
	}
	#warn "Resolved $link to $name\n";
	return $name;
}

sub resolve_case { die 'BUG: not implemented: '.ref($_[0])."->resolve_case()\n" }

=item C<copy_page(SOURCE, TARGET)>

Copy contents of object SOURCE to object TARGET.
Both page objects should belong to this repository.

Make sure to update the page objects correctly.
For example set status and update or flush the parse tree.

=cut

sub copy_page {
	my ($self, $source, $target) = @_;
	croak "usage: copy_page(OBJECT, OBJECT)"
		unless ref $source and ref $target;
	$target->clone($source);
}

=item C<move_page(SOURCE, TARGET)>

Move the content of object SOURCE to object TARGET.
Both page objects should belong to this repository.

Make sure to update the page objects correctly.
For example set status and update or flush the parse tree.

The default just calls C<copy_page()> and C<delete_page()>.

=cut

sub move_page {
	my ($self, $source, $target) = @_;
	croak "usage: move_page(OBJECT, OBJECT)"
		unless ref $source and ref $target;
	$self->copy_page($source, $target);
	$source->delete;
}

=item C<delete_page(PAGE)>

Delete object PAGE and returns the page object.
Be aware that although the content is deleted the PAGE object
goes on living and should be updated accordingly.
The status of the object should be set to 'deleted'.

The default method fails by exception.

=cut

sub delete_page { die 'BUG: not implemented: '.ref($_[0])."->delete_page()\n" }

=item C<search()>

TODO

=cut

sub search { } # make this dispatch to specific methods for each type, use array to order by cost

=back

=head2 Utility methods

These methods are commonly used methods in repository objects.
They do not need to be overloaded.

=over 4

=item C<clean_name(NAME, RELATIVE)>

Class function that returns a sanatized page name.
Removes forbidden chars etc.

If RELATIVE is true the name is not made absolute.

=cut

sub clean_name {
	my (undef, $name, $rel) = @_;
	#print STDERR "resolved $name to ";
	$name =~ s/^:*/:/ unless $rel;		# absolute name
	$name =~ s/:+$//;			# not a namespace
	$name =~ s/::+/:/g;			# replace multiple ":"
	$name =~ s/[^:\w\.\-\(\)\%]/_/g;	# replace forbidden chars
	$name =~ s/(:+)[\_\.\-\(\)]+/$1/g;	# remove non-letter at begin
	$name =~ s/_+(:|$)/$1/g;		# remove trailing underscore
	#print STDERR "$name\n";
	$name = undef if $name eq ':';
	return $name;
}

=item C<root()>

Returns the top parent repository object. This is used to get pages when
we are not sure these pages belong to our repository.

=cut

sub root {
	my $self = shift;
	my $obj = $self;
	while (
		defined $obj->{parent}
		and ref($obj->{parent}) ne 'HASH' # Auto-Vivication Grrr
	) {
		$obj = $obj->{parent};
		last if $obj eq $self; # prevent infinite loop
	}
	return $obj;
}

=item C<check_dir()>

Checks for a "dir" attribute.
Check if parent has a dir and derives from that.
Dies on failure.

=cut

sub check_dir {
	my $self = shift;
	unless (defined $self->{dir}) {
		# no dir given, find one based on namespace
		die ref($self)." needs a directory to initialize\n"
			unless length $self->{parent}{dir};
		my @parts = grep length($_), split /:+/, $self->{namespace};
		$self->{dir} = Zim::File->resolve_file(
			{is_dir => 1}, $$self{parent}{dir}, @parts );
	}
	else { # check dir relative to parent
		$self->{dir} = Zim::File->abs_path(
				$self->{dir}, $self->{parent}{dir} );
	}
	warn "## ".ref($self)." using dir: $self->{dir}\n";
}

=item C<wipe_array(REF)>

Removes double items from the array refered to by ref.

=cut

sub wipe_array {
	my $ref = pop;
	@$ref = sort @$ref;
	my $prev = '';
	for (@$ref) {
		if ($_ eq $prev) { $_ = undef }
		else             { $prev = $_ }
	}
	@$ref = grep defined($_), @$ref;
	return $ref;
}

1;

__END__

=back

=head1 BUGS

Please mail the author if you find any bugs.

=head1 AUTHOR

Jaap Karssenberg || Pardus [Larus] E<lt>pardus@cpan.orgE<gt>

Copyright (c) 2006 Jaap G Karssenberg. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=head1 SEE ALSO

L<Zim>

=cut
